home *** CD-ROM | disk | FTP | other *** search
/ Hardcore Visual Basic 5.0 (2nd Edition) / Hardcore Visual Basic 5.0 - Second Edition (1997)(Microsoft Press).iso / Code / draw.bas < prev    next >
BASIC Source File  |  1997-06-14  |  7KB  |  186 lines
  1. Attribute VB_Name = "MDraw"
  2. Option Explicit
  3.  
  4. Const PI = 3.1415
  5.  
  6. Sub BmpSpiral(picSrc As Picture, cvsDst As Object)
  7. With cvsDst
  8.     ' Calculate sizes
  9.     Dim dxSrc As Long, dySrc As Long, dxDst As Long, dyDst As Long
  10.     dxSrc = .ScaleX(picSrc.Width): dySrc = .ScaleY(picSrc.Height)
  11.     dxDst = .ScaleWidth: dyDst = .ScaleHeight
  12.     ' Set defaults (play with these numbers for different effects)
  13.     Dim xInc As Long, yInc As Long, xSize As Long, ySize As Long
  14.     Dim x As Long, y As Long
  15.     xInc = CInt(dxSrc * 0.01): yInc = CInt(dySrc * 0.01)
  16.     xSize = CInt(dxSrc * 0.1): ySize = CInt(dySrc * 0.1)
  17.     Dim radCur As Single, degCur As Integer, angInc As Integer
  18.     degCur = 0: angInc = 55
  19.     ' Start in center
  20.     x = (dxDst \ 2) - (dxSrc \ 2): y = (dyDst \ 2) - (dySrc \ 2)
  21.     
  22.     ' Spiral until off destination
  23.     Do
  24.         ' Draw at current position
  25.         .PaintPicture picSrc, x, y, , , , , , , vbSrcAnd
  26.         ' Calculate angle in radians
  27.         radCur = (degCur - 90) * (PI / 180)
  28.         ' Calculate next x and y
  29.         x = x + (xSize * Cos(radCur))
  30.         y = y + (ySize * Sin(radCur))
  31.         ' Widen spiral
  32.         xSize = xSize + xInc: ySize = ySize + yInc + 1
  33.         ' Turn angle
  34.         degCur = (degCur + angInc) Mod 360
  35.     Loop While (x > 0) And (x + dxSrc < dxDst - dxSrc) And _
  36.                (y > 0) And (y + dySrc < dyDst)
  37. End With
  38. End Sub
  39.  
  40. Sub SpiralBmp(picSrc As Picture, cvsDst As Object, _
  41.               ByVal xOff As Long, ByVal yOff As Long)
  42. With cvsDst
  43.     Dim xLeft As Long, xRight As Long, yTop As Long, yBottom As Long
  44.     Dim dxSrc As Long, dySrc As Long, xSrc As Long, ySrc As Long
  45.     Dim xDst As Long, yDst As Long, xInc As Long, yInc As Long
  46.     Dim x As Long, y As Long
  47.     ' Initialize
  48.     dxSrc = .ScaleX(picSrc.Width): dySrc = .ScaleY(picSrc.Height)
  49.     xInc = dxSrc / 20: yInc = dySrc / 20
  50.     xLeft = 0: yTop = 0:
  51.     xRight = dxSrc - xInc: yBottom = dySrc - yInc
  52.  
  53.     ' Draw each side
  54.     Do While (xLeft <= xRight) And (yTop <= yBottom)
  55.         ' Top
  56.         For x = xLeft To xRight Step xInc
  57.             .PaintPicture picSrc, x + xOff, y + yOff, xInc, yInc, _
  58.                 x, y, xInc, yInc, vbSrcCopy
  59.         Next
  60.         x = x - xInc: yTop = yTop + yInc
  61.         ' Right
  62.         For y = yTop To yBottom Step yInc
  63.             .PaintPicture picSrc, x + xOff, y + yOff, xInc, yInc, _
  64.                 x, y, xInc, yInc, vbSrcCopy
  65.         Next
  66.         y = y - yInc: xRight = x - xInc
  67.         ' Bottom
  68.         For x = xRight To xLeft Step -xInc
  69.             .PaintPicture picSrc, x + xOff, y + yOff, xInc, yInc, _
  70.                 x, y, xInc, yInc, vbSrcCopy
  71.         Next
  72.         x = x + xInc: yBottom = y - yInc
  73.         ' Left
  74.         For y = yBottom To yTop Step -yInc
  75.             .PaintPicture picSrc, x + xOff, y + yOff, xInc, yInc, _
  76.                 x, y, xInc, yInc, vbSrcCopy
  77.         Next
  78.         y = y + yInc: xLeft = xLeft + xInc
  79.     Loop
  80. End With
  81. End Sub
  82.  
  83. Sub Star(ByVal x As Long, ByVal y As Long, ByVal dxyRadius As Long, _
  84.          clrBorder As Long, clrOut As Long, clrIn As Long, cvsDst As Object)
  85. With cvsDst
  86.     ' Start is 144 degrees (converted to radians)
  87.     Const radStar As Double = 144 * PI / 180
  88.     
  89.     ' Calculate each point
  90.     Dim ptPoly(1 To 5) As POINTL, i As Integer
  91.     For i = 1 To 5
  92.         ptPoly(i).x = x + (Cos(i * radStar) * dxyRadius)
  93.         ptPoly(i).y = y + (Sin(i * radStar) * dxyRadius)
  94.     Next
  95.     
  96.     ' Set colors and style for star
  97.     .ForeColor = clrBorder    ' SetTextColor
  98.     .FillColor = clrOut       ' CreateSolidBrush
  99.     .FillStyle = vbSolid      ' More CreateSolidBrush
  100.     
  101.     'Call VBPolygon(.hDC, ptPoly)
  102.     
  103.     ' Set color for center
  104.     .FillColor = clrIn        ' CreateSolidBrush
  105.     Call MGdiTool.VBFloodFill(.hDC, x, y, .ForeColor)
  106. End With
  107. End Sub
  108.  
  109. Sub Fade(obj As Object, _
  110.          Optional fRed As Boolean = False, _
  111.          Optional fGreen As Boolean = False, _
  112.          Optional fBlue As Boolean = True, _
  113.          Optional fVert As Boolean = True, _
  114.          Optional fHoriz As Boolean = False, _
  115.          Optional fLightToDark As Boolean = True)
  116.  
  117. With obj
  118.  
  119.     ' Trap errors
  120.     On Error Resume Next
  121.     
  122.     ' Save properties
  123.     Dim fAutoRedraw As Boolean, ordDrawStyle As Integer
  124.     Dim ordDrawMode As Integer, iDrawWidth As Integer
  125.     Dim ordScaleMode As Integer, ordPaletteMode As Integer
  126.     Dim rScaleWidth As Single, rScaleHeight As Single
  127.     fAutoRedraw = .AutoRedraw: iDrawWidth = .DrawWidth
  128.     ordDrawStyle = .DrawStyle: ordDrawMode = .DrawMode
  129.     rScaleWidth = .ScaleWidth: rScaleHeight = .ScaleHeight
  130.     ordScaleMode = .ScaleMode
  131.     ' Err set if object lacks one of previous properties
  132.     If Err Then Exit Sub
  133.     ' Only forms have PaletteMode, but ignore errors
  134.     If .PaletteMode <> 1 Then ordPaletteMode = .PaletteMode
  135.     ' If you get here, object is OK (Printer lacks AutoRedraw)
  136.     fAutoRedraw = .AutoRedraw
  137.     
  138.     ' Set properties required for fade
  139.     .AutoRedraw = True
  140.     .DrawWidth = 2   ' Required for dithering
  141.     .DrawStyle = vbInsideSolid: .DrawMode = vbCopyPen
  142.     .ScaleMode = vbPixels
  143.     .ScaleWidth = 256 * 2: .ScaleHeight = 256 * 2
  144.     '.PaletteMode = vbPaletteModeUseZOrder
  145.     .PaletteMode = vbPaletteModeHalftone
  146.     '.Palette = .Picture
  147.     '.PaletteMode = vbPaletteModeCustom
  148.     
  149.     Dim clr As Long, i As Integer, x As Integer, y As Integer
  150.     Dim iRed As Integer, iGreen As Integer, iBlue As Integer
  151.     For i = 0 To 255
  152.         ' Set line color
  153.         If fLightToDark Then
  154.             If fRed Then iRed = 255 - i
  155.             If fBlue Then iBlue = 255 - i
  156.             If fGreen Then iGreen = 255 - i
  157.         Else
  158.             If fRed Then iRed = i
  159.             If fBlue Then iBlue = i
  160.             If fGreen Then iGreen = i
  161.         End If
  162.         clr = RGB(iRed, iGreen, iBlue)
  163.         ' Draw each line of fade
  164.         If fVert Then
  165.             obj.Line (0, y)-(.ScaleWidth, y + 2), clr, BF
  166.             y = y + 2
  167.         End If
  168.         If fHoriz Then
  169.             obj.Line (x, 0)-(x + 2, .ScaleHeight), clr, BF
  170.             x = x + 2
  171.         End If
  172.     Next
  173.     ' Put things back the way you found them
  174.     .AutoRedraw = fAutoRedraw: .DrawWidth = iDrawWidth
  175.     .DrawStyle = ordDrawStyle: .DrawMode = ordDrawMode
  176.     .ScaleMode = ordScaleMode
  177.     .ScaleWidth = rScaleWidth: .ScaleHeight = rScaleHeight
  178.     .PaletteMode = ordPaletteMode
  179. End With
  180. End Sub
  181. '
  182.  
  183.  
  184.  
  185.  
  186.